﻿
'这里是控件主模块 ==================
'  VisualFreeBasic 控件工作流程
'VFB启动时扫描控件文件夹里的每个文件夹，每个文件夹其中一个为 控件DLL，也就是本工程生产的DLL
'第1步：动态加载DLL
'第2步：检查DLL输出函数，都存在继续下一步，否则认为不是 控件DLL 就卸载DLL
'第3步：调用  initialization  来确定协议版本，不符合的就VFB会提示需要多少版本的。并且卸载DLL
'第4步：调用  SetControlProperty 由 DLL来加载控件属性
'当打开一个工程用到本控件时，调用 Edit_AddControls 加载控件到 窗口编辑器
'用户修改或加载控件后，调用 Edit_SetControlProperty 来设置 窗口编辑器中控件 属性
'若控件有特殊属性需要在线处理，调用 Edit_ControlPropertyAlter 来设置，此时由本DLL负责处理，比如 菜单编辑
'当虚拟控件需要绘画时，调用 Edit_OnPaint 来画控件，实体控件是系统负责画，就不需要了。
'编译软件时，调用 Compile_ExplainControl 解析控件，把控件属性翻译成具体代码。
'而控件类是提供给代码调用的。


Function initialization() As Long Export '初始化
                        '当 VFB5 主软件加载本DLL后，主动调用一下此函数，可以在此做初始化代码
   SetFunctionAddress() '设置函数地址
   Function = 7 '返回协议版本号，不同协议（发生接口变化）不能通用，会发生崩溃等问题，因此VFB主软件会判断此版本号，不匹配就不使用本控件。
End Function
Function SetControlProperty(ByRef ColTool As ColToolType) As Long Export '设置控件工具属性。
   '处理多国语言 -----  如果本控件不支持多国语言，可以删除
   Dim op     As pezi Ptr     = GetOpAPP()
   Dim ExeApp As APP_TYPE Ptr = GetExeAPP()
   vfb_LoadLanguage(ExeApp->Path & "Languages\" & op->Languages & "\Languages.txt" ,App.EXEName)
   
   '设置控件基本属性 --------------
   ColTool.sName     = "Slider"               'Name      控件名称，必须英文
   ColTool.sTips     = vfb_LangString("滑块") 'Tips      鼠标停留在控件图标上提示的内容
   ColTool.uName     = UCase(ColTool.sName)
   ColTool.sVale     = &HE672                     'Ico       字体图标的字符值，字体文件在：VisualFreeBasic5\Settings\iconfont.ttf  如果有 *.ico 文件则优先显示图标文件，而不是字体图标。
   ColTool.Feature   = 2                          'Feature   特征 =0 不使用 =1 主窗口(只能有1个，且永远在第一个) =2 普通控件（有窗口句柄） =3 虚拟控件有界面（无句柄） =4 虚拟控件无界面（组件）
   ColTool.ClassFile = "ClsSlider.inc"            'ClassFile 控件类文件名
   ColTool.Only      = 0                          'Only      是否是唯一的，就是一个窗口只能有1个此控件
   ColTool.GROUP     = vfb_LangString("扩展控件") 'Group     分组名称，2个中文到4个最佳，属于多个分组，用英文豆号分割
   
   '设置控件的属性（窗口编辑器里的属性和选项，写代码的属性是控件类负责，代码提示则在帮助里修改。）和事件（代码编辑时可选的事件）
   '从配置文件中读取属性和事件，必须保证和DLL同文件下的 Attribute.ini Event.ini 配置文件正常
   '若不想用配置文件，也可以直接用代码赋值配置。
   'language <>0支持多国语言，会去VFB主语言文件里读取语言，修改配置里的文字。
   If AttributeOREvent(ColTool ,True) Then Return -1 '返回 -1 表示发生问题，VFB将会直接退出。
   
   Function = 27 '返回 排序号，控件在 IDE 中控件列表的先后位置，必须从2开始，主窗口 Form=0  Pointer=1 ，其它 2--n  从小到大排列
End Function


Function Edit_AddControls(cw As CWindow Ptr,hParent AS HWND,IDC As ULong ,Caption As CWSTR, x As Long, y As Long, w As Long, h As Long,WndProc As Any Ptr) As HWND Export '增加1个控件 
   '编辑：窗口刚被打开，需要新建，返回新建后的控件窗口句柄
   'cw      基于CWindow创建，这是当前窗口的 CWindow 指针
   'hParent 父窗口句柄
   'IDC     控件IDC号
   'Caption 控件标题
   'xywh    位置
   'WndProc 主窗口处理消息的函数地址(窗口消息回调函数)

   Function = cw->AddControl("SLIDER", hParent, IDC, Caption, x, y, w, h,WS_CHILD oR WS_CLIPSIBLINGS Or WS_VISIBLE OR WS_TABSTOP OR TBS_AUTOTICKS OR TBS_HORZ OR TBS_BOTTOM , , , WndProc)

End Function

Function Edit_SetControlProperty(ByRef Control As clsControl, ByRef ColTool As ColToolType, ki As Long) As Long Export '设置控件属性
   '编辑：新创建控件、修改控件属性后，都调用1次
   'Control  窗口中的控件
   'ColTool  当前控件配置和属性
   'ki       被修改的属性索引，=0为全部
   Dim hWndControl As hWnd = Control.nHwnd
   Dim vv As String, cvv As CWSTR, i As Long
   
   For i = 1 To ColTool.plU
      vv = Control.pValue(i) '值是 Utf8 格式
      cvv.UTF8 = YF_Replace(vv, Chr(3, 1), vbCrLf)
      '先设置通用部分
      Select Case ColTool.ProList(i).uName
         Case "CAPTION"
            if ColTool.uName <> "STATUSBAR" Then
               SetWindowTextW hWndControl, cvv.vptr
            End if
            Control.Caption = YF_Replace(vv, Chr(3, 1), vbCrLf)
         Case "ICON"
            Dim pa As String = GetProRunFile(0,4)
            Dim svv As String, fvv As Long = InStr(vv, "|")
            if fvv = 0 Then svv = vv Else svv = Left(vv, fvv -1)
            Dim hIcon As HICON = LoadImage(Null, pa & "images\" & Utf8toStr(svv), IMAGE_ICON, 0, 0, LR_DEFAULTSIZE Or LR_LOADFROMFILE)
            If hIcon Then
               hIcon = AfxSetWindowIcon(hWndControl, ICON_SMALL, hIcon)
               If hIcon Then DestroyIcon(hIcon)
            End If
         Case "LEFT"
            If ki = i Then  '只有控件才设置，主窗口不设置
               Control.nLeft = ValInt(vv)
               FF_Control_SetLoc hWndControl, AfxScaleX(Control.nLeft), AfxScaleY(Control.nTop)
            End If
         Case "TOP"   '只有控件才设置，主窗口不设置
            If ki = i Then
               Control.nTop = ValInt(vv)
               FF_Control_SetLoc hWndControl, AfxScaleX(Control.nLeft), AfxScaleY(Control.nTop)
            End If
         Case "WIDTH"
            If ki = i And ColTool.Feature <> 4 Then
               Control.nWidth = ValInt(vv)
               FF_Control_SetSize hWndControl, AfxScaleX(Control.nWidth), AfxScaleY(Control.nHeight)
            End If
         Case "HEIGHT"
            If ki = i And ColTool.Feature <> 4 Then
               Control.nHeight = ValInt(vv)
               FF_Control_SetSize hWndControl, AfxScaleX(Control.nWidth), AfxScaleY(Control.nHeight)
            End If
         Case "CHILD"
         Case "MOUSEPOINTER"
         Case "FORECOLOR"
            Control.ForeColor = GetColorText(vv)
         Case "BACKCOLOR"
            Control.BackColor = GetColorText(vv)
         Case "TAG"
         Case "TAB"
         Case "ACCEPTFILES"
         Case "INDEX"
         Case "FONT"
            Dim tFont As HFONT = GetWinFontLog(vv)
            SendMessage hWndControl, WM_SETFONT, Cast(wParam, tFont), True
            Control.Font = vv
         Case "TOOLTIPBALLOON"
         Case "TOOLTIP"
            '==============     以上是公共设置，下面是每个控件私有设置    =================
         Case "STYLE"  '\样式\2\指示控件边界的外观和行为。\1 - 刻度在底部\0 - 刻度在顶部,1 - 刻度在底部,2 - 刻度在左边,3 - 刻度在右边,4 - 刻度在上下,5 - 刻度在左右
            Select Case ValUInt(vv)
               Case 0  '
                  AfxRemoveWindowStyle hWndControl, TBS_VERT
                  AfxRemoveWindowStyle hWndControl, TBS_BOTTOM
                  AfxRemoveWindowStyle hWndControl, TBS_RIGHT
                  AfxRemoveWindowStyle hWndControl, TBS_BOTH
                  AfxRemoveWindowStyle hWndControl, TBS_LEFT
                  
                  AfxAddWindowStyle hWndControl, TBS_HORZ
                  AfxAddWindowStyle hWndControl, TBS_TOP
               Case 1  '
                  AfxRemoveWindowStyle hWndControl, TBS_VERT
                  AfxRemoveWindowStyle hWndControl, TBS_TOP
                  AfxRemoveWindowStyle hWndControl, TBS_RIGHT
                  AfxRemoveWindowStyle hWndControl, TBS_BOTH
                  AfxRemoveWindowStyle hWndControl, TBS_LEFT
                  
                  AfxAddWindowStyle hWndControl, TBS_HORZ
                  AfxAddWindowStyle hWndControl, TBS_BOTTOM
               Case 2  '
                  AfxRemoveWindowStyle hWndControl, TBS_HORZ
                  AfxRemoveWindowStyle hWndControl, TBS_TOP
                  AfxRemoveWindowStyle hWndControl, TBS_RIGHT
                  AfxRemoveWindowStyle hWndControl, TBS_BOTH
                  AfxRemoveWindowStyle hWndControl, TBS_BOTTOM
                  
                  AfxAddWindowStyle hWndControl, TBS_VERT
                  AfxAddWindowStyle hWndControl, TBS_LEFT
               Case 3  '
                  AfxRemoveWindowStyle hWndControl, TBS_HORZ
                  AfxRemoveWindowStyle hWndControl, TBS_TOP
                  AfxRemoveWindowStyle hWndControl, TBS_LEFT
                  AfxRemoveWindowStyle hWndControl, TBS_BOTH
                  AfxRemoveWindowStyle hWndControl, TBS_BOTTOM
                  
                  AfxAddWindowStyle hWndControl, TBS_VERT
                  AfxAddWindowStyle hWndControl, TBS_RIGHT
               Case 4 '
                  AfxRemoveWindowStyle hWndControl, TBS_VERT
                  AfxRemoveWindowStyle hWndControl, TBS_TOP
                  AfxRemoveWindowStyle hWndControl, TBS_LEFT
                  AfxRemoveWindowStyle hWndControl, TBS_RIGHT
                  AfxRemoveWindowStyle hWndControl, TBS_BOTTOM
                  
                  AfxAddWindowStyle hWndControl, TBS_HORZ
                  AfxAddWindowStyle hWndControl, TBS_BOTH
               Case 5 '
                  AfxRemoveWindowStyle hWndControl, TBS_HORZ
                  AfxRemoveWindowStyle hWndControl, TBS_TOP
                  AfxRemoveWindowStyle hWndControl, TBS_LEFT
                  AfxRemoveWindowStyle hWndControl, TBS_RIGHT
                  AfxRemoveWindowStyle hWndControl, TBS_BOTTOM
                  
                  AfxAddWindowStyle hWndControl, TBS_VERT
                  AfxAddWindowStyle hWndControl, TBS_BOTH
            End Select
         Case "AUTOTICKS"  '\增量刻度\2\每个增量都有一个刻度标记。\TRUE\TRUE,FALSE
            If UCase(vv) = "TRUE" Then AfxAddWindowStyle hWndControl, TBS_AUTOTICKS Else AfxRemoveWindowStyle hWndControl, TBS_AUTOTICKS
         Case "NOTICKS"  '\无刻度\2\不显示任何刻度标记。\FALSE\TRUE,FALSE
            If UCase(vv) = "TRUE" Then AfxAddWindowStyle hWndControl, TBS_NOTICKS Else AfxRemoveWindowStyle hWndControl, TBS_NOTICKS
         Case "ENABLESELRANGE"  '\选择范围\2\仅显示选择范围。选择范围的开始和结束位置的刻度标记显示为三角形（而不是垂直虚线），并且选择范围突出显示。\FALSE\TRUE,FALSE
            If UCase(vv) = "TRUE" Then AfxAddWindowStyle hWndControl, TBS_ENABLESELRANGE Else AfxRemoveWindowStyle hWndControl, TBS_ENABLESELRANGE
         Case "FIXEDLENGTH"  '\可改滑块\2\允许使用TBM_SETTHUMBLENGTH消息更改滑块的大小。\FALSE\TRUE,FALSE
            If UCase(vv) = "TRUE" Then AfxAddWindowStyle hWndControl, TBS_FIXEDLENGTH Else AfxRemoveWindowStyle hWndControl, TBS_FIXEDLENGTH
         Case "NOTHUMB"  '\无滑块\2\不显示滑块。\FALSE\TRUE,FALSE
            If UCase(vv) = "TRUE" Then AfxAddWindowStyle hWndControl, TBS_NOTHUMB Else AfxRemoveWindowStyle hWndControl, TBS_NOTHUMB
         Case "TOOLTIPS"  '\提示位置\2\踪栏控件支持工具提示。当使用此样式创建一个跟踪控件时，它会自动创建一个显示滑块当前位置的默认TOOLTIP控件。您可以使用TBM_SETTIPSIDE消息更改工具提示的显示位置。\FALSE\TRUE,FALSE
            If UCase(vv) = "TRUE" Then AfxAddWindowStyle hWndControl, TBS_TOOLTIPS Else AfxRemoveWindowStyle hWndControl, TBS_TOOLTIPS
         Case "MAX"  '\最大值\0\滚动条的最大值\100\
            FF_TrackBar_SetRangeMax hWndControl, 0, ValInt(vv)
         Case "MIN"  '\最小值\0\滚动条的最小值\1\
            FF_TrackBar_SetRangeMin hWndControl, 0, ValInt(vv)
         Case "VALUE"  '\值\0\滚动条初始值\1\
            FF_TrackBar_SetPos hWndControl, True, ValInt(vv)
         Case "TICKFREQUENCY"  '\大变\0\在滑块的范围内以规则的间隔设置刻度线。\10\
            FF_TrackBar_SetTicFreq hWndControl, ValInt(vv)
      End Select
   Next
   Function = 0
End Function

Function Edit_ControlPropertyAlter(hWndForm As hWnd, hWndList As hWnd, nType As Long, value As String, default As String, AllList As String, nName As String, FomName As String) As Long Export  ' 控件属性修改
   '编辑：用户点击窗口属性，修改属性时，1--6由EXE处理，7 或其它由本DLL处理
   'hWndForm   EXE 主窗口句柄
   'hWndList   控件属性显示窗口句柄（是List控件）Dim z As ZString Ptr = Cast(Any Ptr ,FF_ListBox_GetItemData(aa.hWndList,Index)) '当前属性值
   'nType      类型，由 Attribute.ini 里设置，7 或其它由本DLL处理
   'value      当前的值
   'default    默认值，由 Attribute.ini 里设置
   'AllList    所有值，由 Attribute.ini 里设置
   Select Case nType  '这里根据需要编写
      Case 100
         Dim aa As StyleFormType
         'aa.hWndForm = hWndForm
         'aa.hWndList = hWndList
         'aa.nType = nType
         'aa.value = @value
         'aa.default = @default
         'aa.AllList = @AllList
         'aa.Rvalue = value
         'aa.nName = nName : aa.FomName = FomName '当前被编辑的控件名和窗口名
         'StyleForm.Show hWndForm, True, Cast(Integer, @aa)
         value = aa.Rvalue
         Function = len(value)
         
   End Select
End Function
Function Edit_OnPaint(gg As yGDI, Control As clsControl, ColTool As ColToolType, WinCc As Long, nFile As String) as Long Export '描绘控件
   '编辑：当被刷新窗口，需要重绘控件时，窗口和实控件由系统绘画，不需要我们在这里处理，虚拟控件必须由此画出来。
   'gg    目标， 画在这个缓冲里。
   'Control  窗口中的控件
   'ColTool  当前控件配置和属性
   'WinCc    主窗口底色，不是本控件底色
   'nFile    当前工程主文件名，带文件夹，用来提取路径用。
   '返回非0  将会立即结束描绘操作，就是在此之后的控件就不会画了。按照最底层的控件先画。
   
   
   Function = 0
End Function
Function Compile_ExplainControl(Control As clsControl ,ColTool As ColToolType ,ProWinCode As String ,ussl() As String ,ByRef IDC As Long ,DECLARESdim As String ,Form_clName as String ,nFile As String) as Long Export '解释控件，制造创建控件和事件的代码
   '编译：解释控件 ，注意：编译处理字符全部为 UTF8 编码。Control和ColTool里的是 A字符。
   'Control      窗口中的控件
   'ColTool      当前控件配置和属性
   'ProWinCode   处理后的窗口代码，最初由窗口加载窗口模板处理，然后分发给其它控件。填充处理
   'ussl()       已特殊处理过的用户写的窗口代码，主要用来识辨事件
   'IDC          控件IDC，每个控件唯一，VFB自动累计1，我们代码也可以累计
   'DECLARESdim  全局变量定义，整个工程的定义都在此处
   'Form_clName  主窗口类名，最初由窗口设置，方便后面控件使用。
   'nFile        窗口文件名，用在事件调用注释，出错时可以提示源文件地方，避免提示临时文件。
   
   
   '创建控件 ------------------------------
   Dim ii As Long
   Dim As String clClName ,clName ,clStyle ,clExStyle ,clPro
   
   Dim As Long clType '为了解释代码里用，>=100 为虚拟控件  100=LABEL 1=TEXT
   clName = StrToUtf8(Control.nName)
   If Control.Index > -1 Then clName &= "(" & Control.Index & ")"
   clClName  = "SLIDER"
   clType    = 0
   clStyle   = "WS_CHILD,WS_VISIBLE,WS_CLIPSIBLINGS,WS_TABSTOP"
   clExStyle = ""
   For ii = 1 To ColTool.plU
      if ExplainControlPublic(Form_clName ,Control ,clName ,ii ,ColTool.ProList(ii).uName ,clType ,clStyle ,clExStyle ,clPro ,ProWinCode) Then '处理公共部分，已处理返回0，未处理返回非0
         Select Case ColTool.ProList(ii).uName
               'Case "NAME"  '名称\1\用来代码中识别对象的名称
               'Case "INDEX"  '数组索引\0\控件数组中的控件位置的索引数字。值小于零表示不是控件数组
               'Case "CAPTION"  '文本\1\显示的文本\Label\
               'Case "TEXT"  '文本\1\显示的文本\Label\
               'Case "ENABLED"  '允许\2\创建控件时最初是否允许操作。\True\True,False
               'Case "VISIBLE"  '显示\2\创建控件时最初是显示或隐藏。\True\True,False
               'Case "FORECOLOR"  '文字色\3\用于在对象中显示文本和图形的前景色。\SYS,8\
               'Case "BACKCOLOR"  '背景色\3\用于在对象中显示文本和图形的背景色。\SYS,15\
               'Case "FONT"  '字体\4\用于此对象的文本字体。\微软雅黑,9,0\
               'Case "LEFT"  '位置X\0\左边缘和父窗口的左边缘之间的距离。自动响应DPI缩放\0\
               'Case "TOP"  '位置Y\0\内部上边缘和父窗口的顶部边缘之间的距离。自动响应DPI缩放\0\
               'Case "WIDTH"  '宽度\0\窗口宽度，100%DPI时的像素单位，自动响应DPI缩放。\100\
               'Case "HEIGHT"  '高度\0\窗口高度，100%DPI时的像素单位，自动响应DPI缩放。\20\
               'Case "LAYOUT"
               'Case "MOUSEPOINTER"  '鼠标指针\2\鼠标在窗口上的形状\0 - 默认\0 - 默认,1 - 后台运行,2 - 标准箭头,3 - 十字光标,4 - 箭头和问号,5 - 文本工字光标,6 - 不可用禁止圈,7 - 移动,8 - 双箭头↙↗,9 - 双箭头↑↓,10 - 双箭头向↖↘,11 - 双箭头←→,12 - 垂直箭头,13 - 沙漏,14 - 手型
               'Case "TAG"  '附加\1\私有自定义文本与控件关联。\\
               'Case "TAB"  '导航\2\当用户按下TAB键时可以接收键盘焦点。\False\True,False
               'Case "TOOLTIP"  '提示\1\一个提示，当鼠标光标悬停在控件时显示它。\\
               'Case "TOOLTIPBALLOON"  '气球样式\2\一个气球样式显示工具提示。\False\True,False
               'Case "ACCEPTFILES"  '拖放\2\窗口是否接受拖放文件。\False\True,False
               '==============     以上是公共设置，下面是每个控件私有设置    =================
            Case "STYLE" '\样式\2\指示控件边界的外观和行为。\1 - 刻度在底部\0 - 刻度在顶部,1 - 刻度在底部,2 - 刻度在左边,3 - 刻度在右边,4 - 刻度在上下,5 - 刻度在左右
               Select Case ValUInt(Control.pValue(ii))
                  Case 0 '
                     clStyle = TextAddWindowStyle(clStyle ,"TBS_HORZ")
                     clStyle = TextAddWindowStyle(clStyle ,"TBS_TOP")
                  Case 1 '
                     clStyle = TextAddWindowStyle(clStyle ,"TBS_HORZ")
                     clStyle = TextAddWindowStyle(clStyle ,"TBS_BOTTOM")
                  Case 2 '
                     clStyle = TextAddWindowStyle(clStyle ,"TBS_VERT")
                     clStyle = TextAddWindowStyle(clStyle ,"TBS_LEFT")
                  Case 3 '
                     clStyle = TextAddWindowStyle(clStyle ,"TBS_VERT")
                     clStyle = TextAddWindowStyle(clStyle ,"TBS_RIGHT")
                  Case 4 '
                     clStyle = TextAddWindowStyle(clStyle ,"TBS_HORZ")
                     clStyle = TextAddWindowStyle(clStyle ,"TBS_BOTH")
                  Case 5 '
                     clStyle = TextAddWindowStyle(clStyle ,"TBS_VERT")
                     clStyle = TextAddWindowStyle(clStyle ,"TBS_BOTH")
               End Select
            Case "AUTOTICKS" '\增量刻度\2\每个增量都有一个刻度标记。\TRUE\TRUE,FALSE
               If UCase(Control.pValue(ii)) = "TRUE" Then clStyle = TextAddWindowStyle(clStyle ,"TBS_AUTOTICKS")
            Case "NOTICKS" '\无刻度\2\不显示任何刻度标记。\FALSE\TRUE,FALSE
               If UCase(Control.pValue(ii)) = "TRUE" Then clStyle = TextAddWindowStyle(clStyle ,"TBS_NOTICKS")
            Case "ENABLESELRANGE" '\选择范围\2\仅显示选择范围。选择范围的开始和结束位置的刻度标记显示为三角形（而不是垂直虚线），并且选择范围突出显示。\FALSE\TRUE,FALSE
               If UCase(Control.pValue(ii)) = "TRUE" Then clStyle = TextAddWindowStyle(clStyle ,"TBS_ENABLESELRANGE")
            Case "FIXEDLENGTH" '\可改滑块\2\允许使用TBM_SETTHUMBLENGTH消息更改滑块的大小。\FALSE\TRUE,FALSE
               If UCase(Control.pValue(ii)) = "TRUE" Then clStyle = TextAddWindowStyle(clStyle ,"TBS_FIXEDLENGTH")
            Case "NOTHUMB" '\无滑块\2\不显示滑块。\FALSE\TRUE,FALSE
               If UCase(Control.pValue(ii)) = "TRUE" Then clStyle = TextAddWindowStyle(clStyle ,"TBS_NOTHUMB")
            Case "TOOLTIPS" '\提示位置\2\踪栏控件支持工具提示。当使用此样式创建一个跟踪控件时，它会自动创建一个显示滑块当前位置的默认TOOLTIP控件。您可以使用TBM_SETTIPSIDE消息更改工具提示的显示位置。\FALSE\TRUE,FALSE
               If UCase(Control.pValue(ii)) = "TRUE" Then clStyle = TextAddWindowStyle(clStyle ,"TBS_TOOLTIPS")
            Case "MAX" '\最大值\0\滚动条的最大值\100\
               clPro &= "      SNDMSG(hWndControl,TBM_SETRANGEMAX, 0, " & Control.pValue(ii) & ")" & vbCrLf
            Case "MIN" '\最小值\0\滚动条的最小值\1\
               clPro &= "      SNDMSG(hWndControl,TBM_SETRANGEMIN, 0, " & Control.pValue(ii) & ")" & vbCrLf
            Case "VALUE" '\值\0\滚动条初始值\1\
               clPro &= "      SNDMSG(hWndControl,TBM_SETPOS, True, " & Control.pValue(ii) & ")" & vbCrLf
            Case "TICKFREQUENCY" '\大变\0\在滑块的范围内以规则的间隔设置刻度线。\10\
               clPro &= "      SNDMSG(hWndControl,TBM_SETTICFREQ," & Control.pValue(ii) & ",0)" & vbCrLf
         End Select
      End if
   Next
   
    
   Dim CONTROL_CODExx As String
   If Len(clExStyle) = 0 Then clExStyle = "0"
   If Len(clStyle) = 0   Then clStyle   = "0"
   '真实控件========
   Dim CaptionTxt As String = GetTextToOutText(Control.Caption) '为编译输出文本转换输出文本，可能是多国语言，转换为多国语言字符
   CONTROL_CODExx &= "   hWndControl = pWindow->AddControl(""" & clClName & """, hWnd, " & IDC & ", " & CaptionTxt & ", " & _
      Control.nLeft          & ", "        & Control.nTop       & ", " & Control.nWidth & ", " & Control.nHeight & "," & YF_Replace(clStyle ,"," ," Or ") & " ," & YF_Replace(clExStyle ,"," ," Or ") & _
      " , , Cast(Any Ptr, @" & Form_clName & "_CODEPROCEDURE))" & vbCrLf
   CONTROL_CODExx &= "   If hWndControl Then " & vbCrLf
   CONTROL_CODExx &= "      Dim fp As FormControlsPro_TYPE ptr = new FormControlsPro_TYPE" & vbCrLf
   CONTROL_CODExx &= "      vfb_Set_Control_Ptr(hWndControl,fp)"                           & vbCrLf
   CONTROL_CODExx &= "      fp->hWndParent = hWnd"                                         & vbCrLf
   CONTROL_CODExx &= "      fp->Index = "                                                  & Control.Index & vbCrLf
   CONTROL_CODExx &= "      fp->IDC = "                                                    & IDC           & vbCrLf
   CONTROL_CODExx &= "      fp->nText = "                                                  & CaptionTxt    & vbCrLf
   '   CONTROL_CODExx &= "      fp->ControlType = " & clType & vbCrLf
   CONTROL_CODExx &= "      This." & clName & ".hWnd = hWndControl " & vbCrLf '真实控件========
   CONTROL_CODExx &= "      This." & clName & ".IDC ="               & IDC & vbCrLf
   
   CONTROL_CODExx &= clPro
   CONTROL_CODExx &= "   End IF" & vbCrLf
   Insert_code(ProWinCode ,"'[Create control]" ,CONTROL_CODExx)
   
   '事件处理 ------------------------------
   Dim LeaveHoverI As Long
   '控件事件
   For ii = 1 To ColTool.elU
      Dim sim As String '事件函数名组合
      sim = " " & UCase(Form_clName & "_" & StrToUtf8(Control.nName & "_" & ColTool.EveList(ii).sName)) & "("
      Dim ff As Long
      for fi As Long = 0 To UBound(ussl)
         If left(ussl(fi) ,1) <> "'" AndAlso InStr(ussl(fi) ,sim) > 0 Then
            ff = fi + 1
            Exit for
         End If
      Next
      If ff > 0 Then
         if IsEventComparison(Control ,ColTool ,ii ,ff ,nFile ,ussl(ff -1) ,Form_clName) Then Return 3 '检查事件是不是正确
         Select Case ColTool.EveList(ii).tMsg
            Case "NM_CUSTOMDRAW" ,"NM_RELEASEDCAPTURE"
               Dim CONTROLS_NOTIFY As String = "         If (FLY_pNotify->idFrom = " & IDC & ") And (FLY_pNotify->Code = " & ColTool.EveList(ii).tMsg & ") Then" & vbCrLf
               If Right(ColTool.EveList(ii).Param ,1) = ")" Then '是SUB
                  CONTROLS_NOTIFY &= "             " & sim
               Else
                  CONTROLS_NOTIFY &= "              tLResult = " & sim
               end if
               If Control.Index > -1 Then CONTROLS_NOTIFY &= Control.Index & ","
               CONTROLS_NOTIFY &= ColTool.EveList(ii).gCall & "  " & nFile & ff -1 & "]" & vbCrLf
               If Right(ColTool.EveList(ii).Param ,1) <> ")" Then CONTROLS_NOTIFY &= "            If tLResult Then Return tLResult" & vbCrLf
               CONTROLS_NOTIFY &= "         End If"
               Insert_code(ProWinCode ,"'[CONTROLS_NOTIFY]" ,CONTROLS_NOTIFY)
            Case "CUSTOM"
               dim CALL_CONTROL_CUSTOM As String = "    If IDC = " & IDC & " Then  ' " & clName & vbCrLf
               CALL_CONTROL_CUSTOM &= "       tLResult = " & sim
               If Control.Index > -1 Then CALL_CONTROL_CUSTOM &= Control.Index & ","
               CALL_CONTROL_CUSTOM &= ColTool.EveList(ii).gCall                 & "  " & nFile & ff -1 & "]" & vbCrLf
               CALL_CONTROL_CUSTOM &= "       If tLResult Then Return tLResult" & vbCrLf
               CALL_CONTROL_CUSTOM &= "    End If"                              & vbCrLf
               Insert_code(ProWinCode ,"'[CALL_CONTROL_CUSTOM]" ,CALL_CONTROL_CUSTOM)
            Case "WM_HSCROLL" '特殊处理 ,需要在父窗口处理
               Dim FORM_WM_HSCROLL As String = "         If GetDlgCtrlId(Cast(HWND,lParam)) = " & IDC & " Then  ' " & clName & vbCrLf
               FORM_WM_HSCROLL &= "           " & sim
               If Control.Index > -1 Then FORM_WM_HSCROLL &= Control.Index & ","
               FORM_WM_HSCROLL &= ColTool.EveList(ii).gCall & "  " & nFile & ff -1 & "]" & vbCrLf
               FORM_WM_HSCROLL &= "          End If"        & vbCrLf
               Insert_code(ProWinCode ,"'[FORM_WM_HSCROLL]" ,FORM_WM_HSCROLL)
               
            Case "WM_VSCROLL"
               Dim FORM_WM_VSCROLL as String = "         If GetDlgCtrlId(Cast(HWND,lParam)) = " & IDC & " Then  ' " & clName & vbCrLf
               FORM_WM_VSCROLL &= "           " & sim
               If Control.Index > -1 Then FORM_WM_VSCROLL &= Control.Index & ","
               FORM_WM_VSCROLL &= ColTool.EveList(ii).gCall & "  " & nFile & ff -1 & "]" & vbCrLf
               FORM_WM_VSCROLL &= "          End If"        & vbCrLf
               Insert_code(ProWinCode ,"'[FORM_WM_VSCROLL]" ,FORM_WM_VSCROLL)
            Case Else
               If ColTool.EveList(ii).tMsg = "WM_MOUSEHOVER" Then LeaveHoverI Or= 1
               If ColTool.EveList(ii).tMsg = "WM_MOUSELEAVE" Then LeaveHoverI Or= 10
               Dim ca    As String = "      Case "         & ColTool.EveList(ii).tMsg & " ''' "
               Dim other As String = "          If IDC = " & IDC                      & " Then  ' " & clName & vbCrLf
               If Right(ColTool.EveList(ii).Param ,1) <> ")" Then '这是函数
                  other &= "          tLResult = " & sim
                  If Control.Index > -1 Then other &= Control.Index & ","
                  other &= ColTool.EveList(ii).gCall                    & "  " & nFile & ff -1 & "]" & vbCrLf
                  other &= "          If tLResult Then Return tLResult" & vbCrLf
               Else '这是过程
                  other &= "             " & sim
                  If Control.Index > -1 Then other &= Control.Index & ","
                  other &= ColTool.EveList(ii).gCall & "  " & nFile & ff -1 & "]" & vbCrLf
               End If
               other &= "          End If" & vbCrLf
               ff    = InStr(ProWinCode ,ca)
               If ff = 0 Then '不存在
                  Insert_code(ProWinCode ,"'[CONTROL_CASE_OTHER]" ,ca & vbCrLf & other)
               Else '已经有了
                  ProWinCode = Left(ProWinCode ,ff + Len(ca) -1) & vbCrLf & other & Mid(ProWinCode ,ff + Len(ca))
               End If
         End Select
      End If
   Next
   If LeaveHoverI > 0 And LeaveHoverI <> 10 Then '单独=10的离开消息，系统自带，不需要启用
      dim CONTROL_LEAVEHOVER As String = "          If wMsg = WM_MouseMove AndAlso IDC = " & IDC & " Then  ' " & clName & vbCrLf
      CONTROL_LEAVEHOVER &= "             Dim entTrack As tagTRACKMOUSEEVENT"           & vbCrLf
      CONTROL_LEAVEHOVER &= "             entTrack.cbSize = SizeOf(tagTRACKMOUSEEVENT)" & vbCrLf
      If LeaveHoverI = 11 Then
         CONTROL_LEAVEHOVER &= "             entTrack.dwFlags = TME_LEAVE Or TME_HOVER" & vbCrLf
      ElseIf LeaveHoverI = 10 Then
         CONTROL_LEAVEHOVER &= "             entTrack.dwFlags = TME_LEAVE " & vbCrLf
      Else
         CONTROL_LEAVEHOVER &= "             entTrack.dwFlags =  TME_HOVER" & vbCrLf
      End If
      CONTROL_LEAVEHOVER &= "             entTrack.hwndTrack = hWndControl"     & vbCrLf
      CONTROL_LEAVEHOVER &= "             entTrack.dwHoverTime = HOVER_DEFAULT" & vbCrLf
      CONTROL_LEAVEHOVER &= "             TrackMouseEvent @entTrack"            & vbCrLf
      CONTROL_LEAVEHOVER &= "          End IF"                                  & vbCrLf
      Insert_code(ProWinCode ,"'[CONTROL_LEAVEHOVER]" ,CONTROL_LEAVEHOVER)
   End If
   
   '成功返回0，失败非0
   Function = 0
End Function


Function GetCodeColorGDI(coColor As Long) As Long  '把控件特殊颜色值，转换为 GDI 色  ,返回-1 为不使用或默认
  If (&H00FFFFFF And coColor) = &H7F7F7F Then
      Dim f As Long = Cast(UInteger, (&HFF000000 And coColor)) Shr 24
      If f=25 Then  Return -1   '不使用或默认值 
      If f < 31 Then 
          Return GetSysColor(f)  
      End If  
  End If
  Function = (&H00FFFFFF And coColor) '去掉 A 通道
End Function
Function GetCodeColorGDIplue(coColor As Long) As Long  '把控件特殊颜色值，转换为 GDI+ 色  ,返回0 为不使用或默认
  Dim tColor As Long = coColor 
  If (&H00FFFFFF And coColor) = &H7F7F7F Then
      Dim f As Long = Cast(UInteger, (&HFF000000 And coColor)) Shr 24
      If f = 25 Then Return 0  ' 不使用或默认值 
      If f < 31 Then 
          tColor = GetSysColor(f) Or &HFF000000 '增加 A通道，不透明，不然是全透明  
      End If  
  End If 
  '因为保存的是GDI 的颜色，GDI+ 需要调换
  Dim As UInteger c1 =(&H00FF0000 And tColor),c2 = (&H000000FF And tColor) ,c3 =(&HFF00FF00 And tColor)
  c1 Shr= 16
  c2 Shl= 16 
  Function = c1 Or c2 Or c3  
End Function
























